home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGSCAL / TURBOK50.LZH / SOURCE.ARC / MISCTTT5.PAS < prev    next >
Pascal/Delphi Source File  |  1989-06-02  |  19KB  |  699 lines
  1. {--------------------------------------------------------------------------}
  2. {                         TechnoJock's Turbo Toolkit                       }
  3. {                                                                          }
  4. {                              Version   5.01a                             }
  5. {                                                                          }
  6. {                                                                          }
  7. {              Copyright 1986, 1989 TechnoJock Software, Inc.              }
  8. {                           All Rights Reserved                            }
  9. {                          Restricted by License                           }
  10. {--------------------------------------------------------------------------}
  11.  
  12.                      {--------------------------------}                                       
  13.                      {       Unit:  MiscTTT5          }
  14.                      {--------------------------------}
  15.  
  16.  
  17. {$S-,R-,V-}       
  18. {$IFNDEF DEBUG}
  19. {$D-}
  20. {$ENDIF}
  21.  
  22. Unit MiscTTT5;
  23. {Change History : April 1, 1989    Modified Printer Status and added global
  24.                                    LPTport 
  25.                            5.01a   Removed references to VER50 and added
  26.                                    DEBUG compiler directive                                
  27. }
  28. Interface
  29.  
  30. Uses CRT, DOS, FastTTT5, Strnttt5;
  31.  
  32. TYPE
  33.    Dates = word;   {change to longint for greater date ranges}
  34.  
  35. CONST
  36.    MMDDYY   = 1;   {Date formats}
  37.    MMDDYYYY = 2;
  38.    MMYY     = 3;
  39.    MMYYYY   = 4;
  40.    DDMMYY   = 5;
  41.    DDMMYYYY = 6;
  42.  
  43. VAR
  44.    LPTport,     {0=lpt1, 1=lpt2, 2=lpt3}
  45.    ClockX,
  46.    ClockY,
  47.    ClockF,
  48.    ClockB : byte;
  49.  
  50. Function  Exist(Filename:string):boolean;
  51. Function  CopyFile(SourceFile, TargetFile:string): byte;
  52. Function  File_Size(Filename:string): longint;
  53. {$IFNDEF VER40}
  54. Function  File_Drive(Full:string): string;
  55. Function  File_Directory(Full:string): string;
  56. Function  File_Name(Full:string): string;
  57. Function  File_Ext(Full:string): String;
  58. {$ENDIF}
  59. Function  Time: string;
  60. Procedure Clock;
  61. Function  Date: String;
  62. Procedure PrintScreen;
  63. Procedure Beep;
  64. function  Printer_Status:byte;
  65. Function  Alternate_Printer_Status:byte;
  66. Function  Printer_ready:boolean;
  67. Procedure FlushKeyBuffer;
  68. Procedure Reset_Printer;
  69. Function  DMY_to_String(D,M,Y:word;format:byte): string;
  70. Function  Date_To_Julian(InDate:string;format:byte): dates;
  71. Function  Julian_to_Date(J:dates;format:byte):string;
  72. Function  Today_in_Julian: dates;
  73. Function  Date_Within_Range(Min,Max,Test:dates):boolean;
  74. Function  Valid_Date(Indate:string;format:byte): boolean;
  75. Function  Future_Date(InDate:string;format:byte;Days:word): string;
  76. Function  Unformatted_date(InDate:string): string;
  77.  
  78. Implementation
  79.  
  80. Const
  81.     LastYearNextCentuary = 78;
  82.  
  83. Function Exist(Filename:string):boolean;
  84. {returns true if file exists}
  85. var Inf: SearchRec;
  86. begin
  87.     FindFirst(Filename,AnyFile,Inf);
  88.     Exist := (DOSError = 0);
  89. end;  {Func Exist}
  90.  
  91. Function CopyFile(SourceFile, TargetFile:string): byte;
  92. {return codes:  0 successful
  93.                 1 source and target the same
  94.                 2 cannot open source
  95.                 3 unable to create target
  96.                 4 error during copy
  97. }
  98. var
  99.   Source,
  100.   Target : file;
  101.   BRead,
  102.   Bwrite : word;
  103.   FileBuf  : array[1..2048] of char;
  104. begin
  105.     If SourceFile = TargetFile then
  106.     begin
  107.         CopyFile := 1;
  108.         exit;
  109.     end;
  110.     Assign(Source,SourceFile);
  111.     {$I-}
  112.     Reset(Source,1);
  113.     {$I+}
  114.     If IOResult <> 0 then
  115.     begin
  116.         CopyFile := 2;
  117.         exit;
  118.     end;
  119.     Assign(Target,TargetFile);
  120.     {$I-}
  121.     Rewrite(Target,1);
  122.     {$I+}
  123.     If IOResult <> 0 then
  124.     begin
  125.         CopyFile := 3;
  126.         exit;
  127.     end;
  128.     Repeat
  129.          BlockRead(Source,FileBuf,SizeOf(FileBuf),BRead);
  130.          BlockWrite(Target,FileBuf,Bread,Bwrite);
  131.     Until (Bread = 0) or (Bread <> BWrite);
  132.     Close(Source);
  133.     Close(Target);
  134.     If Bread <> Bwrite then
  135.        CopyFile := 4
  136.     else
  137.        CopyFile := 0;
  138. end; {of func CopyFile}
  139.  
  140.  Function File_Size(Filename:string): longint;
  141.  {returns  -1   if file not found}
  142.  var
  143.     F : file of byte;
  144.  begin
  145.      Assign(F,Filename);
  146.      {$I-}
  147.      Reset(F);
  148.      {$I+}
  149.      If IOResult <> 0 then
  150.      begin
  151.         File_Size := -1;
  152.         exit;
  153.      end;
  154.      File_Size := FileSize(F);
  155.      Close(F);
  156.  end; {of func File_Size}
  157.  
  158. {$IFNDEF VER40}
  159.  Function File_Split(Part:byte;Full:string): string;
  160.  {used internally}
  161.  var
  162.     D : DirStr;
  163.     N : NameStr;
  164.     E : ExtStr;
  165.  begin
  166.      FSplit(Full,D,N,E);
  167.      Case Part of
  168.      1 : File_Split := D;
  169.      2 : File_Split := N;
  170.      3 : File_Split := E;
  171.      end;
  172.  end; {of func File_Split}
  173.  
  174.  Function File_Drive(Full:string): string;
  175.  {}
  176.  var
  177.    Temp : string;
  178.    P : byte;
  179.  begin
  180.      Temp := File_Split(1,Full);
  181.      P := Pos(':',Temp);
  182.      If P <> 2 then
  183.         File_Drive := ''
  184.      else
  185.         File_Drive := upcase(Temp[1]);
  186.  end; {of func File_Drive}
  187.  
  188.  Function File_Directory(Full:string): string;
  189.  {}
  190.  var
  191.    Temp : string;
  192.    P : byte;
  193.  begin
  194.      Temp := File_Split(1,Full);
  195.      P := Pos(':',Temp);
  196.      If P = 2 then
  197.         Delete(Temp,1,2);                 {remove drive}
  198.      If (Temp[length(Temp)]  ='\') and (temp <> '\') then
  199.         Delete(temp,length(Temp),1);      {remove last backslash}
  200.      File_Directory := Temp;
  201.  end; {of func File_Directory}
  202.  
  203.  Function File_Name(Full:string): string;
  204.  {}
  205.  begin
  206.      File_Name := File_Split(2,Full);
  207.  end; {of func File_Name}
  208.  
  209.  Function File_Ext(Full:string): String;
  210.  {}
  211.  var
  212.    Temp : string;
  213.  begin
  214.      Temp := File_Split(3,Full);
  215.      If (Temp = '') or (Temp = '.') then
  216.         File_Ext := temp
  217.      else
  218.         File_Ext := copy(Temp,2,3);
  219.  end; {of func File_Ext}
  220. {$ENDIF}
  221. function time: string;
  222. var
  223.   hour,min,sec:     string[2];
  224.   H,M,S,T : word;
  225. begin
  226.     GetTime(H,M,S,T);
  227.     Str(H,Hour);
  228.     Str(M,Min);
  229.     Str(S,Sec);
  230.     if S < 10 then            {pad a leading zero if sec is < 10 }
  231.       sec := '0'+sec;
  232.     if M < 10 then            {pad a leading zero if min is < 10 }
  233.         min := '0'+min;
  234.     if H > 12 then           { assign an a.m. or p.m. string }
  235.     begin
  236.        str(H - 12,hour);
  237.        IF length(hour) = 1 then Hour := ' '+hour;
  238.           time := hour+':'+min+':'+sec+' p.m.'
  239.     end
  240.     else
  241.        time := hour+':'+min+':'+sec+' a.m.';
  242.     if H = 12 then
  243.        time := hour+':'+min+':'+sec+' p.m.';
  244. end;
  245.  
  246. {$F+}
  247. Procedure Clock;
  248. {}
  249. begin
  250.     Fastwrite(ClockX,ClockY,attr(ClockF,ClockB),Time);
  251. end; {of proc Clock}
  252. {$F-}
  253.  
  254. function Date: String;
  255. type
  256.   WeekDays = array[0..6]  of string[9];
  257.   Months   = array[1..12] of string[9];
  258. const
  259.     DayNames   : WeekDays  = ('Sunday','Monday','Tuesday','Wednesday',
  260.                               'Thursday','Friday','Saturday');
  261.     MonthNames : Months    = ('January','February','March','April','May',
  262.                               'June','July','August','September',
  263.                               'October','November','December');
  264. var
  265.  Y,
  266.  M,
  267.  D,
  268.  DayOfWeek : word;
  269.  Year   : string;
  270.  Day    : string;
  271. begin
  272.     GetDate(Y,M,D,DayofWeek);
  273.     Str(Y,Year);
  274.     Str(D,Day);
  275.     Date := DayNames[DayOfWeek]+' '+MonthNames[M]+' '+Day+', '+Year;
  276. end;
  277.  
  278. Procedure PrintScreen;
  279. var Regpack : registers;
  280. begin
  281.     intr($05,regpack);
  282. end;
  283.  
  284. procedure Beep;
  285. begin
  286.     sound(800);Delay(150);
  287.     sound(600);Delay(100);
  288.     Nosound;
  289. end;
  290.  
  291. Function Printer_Status:byte;
  292. {Credits: Robert W. Lewis, VA thanks! Special masking employed for non-
  293.           standard printers, e.g. daisy wheels!!! }
  294. var Recpack : registers;
  295. begin
  296.     with recpack do
  297.     begin
  298.         Ah := 2;
  299.         Dx := LPTport;
  300.         intr($17,recpack);
  301.         If (Ah and $B8) = $90 then
  302.            Printer_Status := 0           {all's well}
  303.         else
  304.            If (Ah and $20) = $20 then
  305.               Printer_Status := 1        {no Paper}
  306.         else
  307.            If (Ah and $10) = $00 then
  308.               Printer_Status := 2        {off line}
  309.         else
  310.            If (Ah and $80) = $00 then
  311.               Printer_Status := 3        {busy}
  312.         else
  313.            If (Ah and $08) = $08 then
  314.               Printer_Status := 4;       {undetermined error}
  315.     end;
  316. end;
  317.  
  318. Function Alternate_Printer_Status:byte;
  319. var Recpack : registers;
  320. begin
  321.     with recpack do
  322.     begin
  323.         Ah := 2;
  324.         Dx := LPTport;
  325.         intr($17,recpack);
  326.         If (Ah and $20) = $20 then
  327.               Alternate_Printer_Status := 1        {no Paper}
  328.         else
  329.            If (Ah and $10) = $00 then
  330.               Alternate_Printer_Status := 2        {off line}
  331.         else
  332.            If (Ah and $80) = $00 then
  333.               Alternate_Printer_Status := 3        {busy}
  334.         else
  335.            If (Ah and $08) = $08 then
  336.               Alternate_Printer_Status := 4        {undetermined error}
  337.         else
  338.             Alternate_Printer_Status := 0           {all's well}
  339.     end;
  340. end;
  341.  
  342.  
  343. function printer_ready :boolean;
  344. begin
  345.     Printer_ready := (Printer_Status = 0);
  346. end;
  347.  
  348. Procedure FlushKeyBuffer;
  349. var Recpack : registers;
  350. begin
  351.     with recpack do
  352.     begin
  353.         Ax := ($0c shl 8) or 6;
  354.         Dx := $00ff;
  355.     end;
  356.     Intr($21,recpack);
  357. end;
  358.  
  359. Procedure Reset_Printer;
  360. var address: integer absolute $0040:$0008;
  361.              portno,delay : integer;
  362. begin
  363.     portno := address + 2;
  364.     port[portno] := 232;
  365.     for delay := 1 to 2000 do {nothing};
  366.     port[portno] := 236;
  367. end;
  368.  
  369. {++++++++++++++++++++++++++++++++++}
  370. {                                  }
  371. {    D A T E    R O U T I N E S    }
  372. {                                  }
  373. {++++++++++++++++++++++++++++++++++}
  374.  
  375. (*
  376.  Note that the Julian date logic applied in these routines is that day 1 is
  377.  January 1, 1900. All subsequent dates are represented by the number of
  378.  days elapsed since day 1. The INTERFACE section includes a declaration of
  379.  type DATES - this is set equal to type word, but it could be changed to
  380.  type longint to provide a much greater date range. 
  381.  
  382.  Throughout these procedures and functions a date "format" must be passed. The
  383.  format codes are:
  384.  
  385.                   1  MM/DD/YY
  386.                   2  MM/DD/YYYY
  387.                   3  MM/YY
  388.                   4  MM/YYYY
  389.                   5  DD/MM/YY {International format}
  390.                   6  DD/MM/YYYY   {   "    }
  391.  
  392.  When passing dates in string form the "separators" are not significant. For
  393.  example, the following strings are all treated alike:
  394.  
  395.                      120188
  396.                      12/01/88
  397.                      12-01-88
  398.                      12-01/88
  399.                      12----01----88
  400.  Only the numerical digits are significant, the alphas are ignored.
  401.  
  402. *)
  403.   Function Nth_Number(InStr:string;Nth:byte) : char;
  404.   {Returns the nth number in an alphanumeric string}
  405.   var
  406.      Counter : byte;
  407.      B, Len : byte;
  408.   begin
  409.       Counter := 0;
  410.       B := 0;
  411.       Len := Length(InStr);
  412.       Repeat
  413.            Inc(B);
  414.            If InStr[B] in ['0'..'9'] then
  415.               Inc(Counter);
  416.       Until (Counter = Nth) or (B >= Len);
  417.       If (Counter >= Len) and ( (InStr[Len] in ['0'..'9']) = false) then
  418.          Nth_Number := #0
  419.       else
  420.          Nth_Number := InStr[B];
  421.   end; {of func Nth_Number}
  422.  
  423.  Function Day(DStr:string;Format:byte): word;
  424.  {INTERNAL}
  425.  var
  426.     DayStr: string;
  427.  begin
  428.      Case Format of
  429.      MMDDYY,
  430.      MMDDYYYY :  DayStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  431.      DDMMYY,
  432.      DDMMYYYY :  DayStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  433.      else     DayStr := '01';
  434.      end;
  435.      Day := Str_To_Int(DayStr);
  436.  end; {of func Day}
  437.  
  438.  Function Month(DStr:string;Format:byte): word;
  439.  {INTERNAL}
  440.  var
  441.     MonStr: string;
  442.  begin
  443.      Case Format of
  444.      MMDDYY,
  445.      MMDDYYYY,
  446.      MMYY,
  447.      MMYYYY    :  MonStr := Nth_Number(DStr,1)+Nth_Number(DStr,2);
  448.      DDMMYY,
  449.      DDMMYYYY  :  MonStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  450.      end;
  451.      Month := Str_To_Int(MonStr);
  452.  end; {of func Month}
  453.  
  454.  Function Year(DStr:string;Format:byte): word;
  455.  {INTERNAL}
  456.  var
  457.     YrStr   : string;
  458.     TmpYr   : word;
  459.  begin
  460.      Case Format of
  461.      MMDDYY,
  462.      DDMMYY   :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6);
  463.      MMDDYYYY,
  464.      DDMMYYYY :  YrStr := Nth_Number(DStr,5)+Nth_Number(DStr,6)+
  465.                      Nth_Number(DStr,7)+Nth_Number(DStr,8);
  466.      MMYY     :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4);
  467.      MMYYYY   :  YrStr := Nth_Number(DStr,3)+Nth_Number(DStr,4)+
  468.                      Nth_Number(DStr,5)+Nth_Number(DStr,6);
  469.      end;
  470.      TmpYr := Str_To_Int(YrStr);
  471.      If TmpYr < LastYearNextCentuary then
  472.         TmpYr := 2000 + TmpYr
  473.      else
  474.         If Tmpyr < 1000 then
  475.            TmpYr := 1900 + TmpYr;
  476.      Year := TmpYr;
  477.  end; {of func Year}
  478.  
  479.  Function DMY_to_String(D,M,Y:word;format:byte): string;
  480.  {INTERNAL}
  481.  const
  482.      PadChar = '/';
  483.  var
  484.     DD,MM,YY : string[4];
  485.  begin
  486.      DD := Int_to_Str(D);
  487.      If D < 10 then
  488.         DD := '0'+DD;
  489.      MM := Int_to_Str(M);
  490.      If M < 10 then
  491.         MM := '0'+MM;
  492.      If Format in [MMDDYY,MMYY,DDMMYY] then
  493.      begin
  494.          If Y > 99 then
  495.             If Y > 2000 then
  496.                Y := Y - 2000
  497.             else
  498.                If Y > 1900 then
  499.                   Y := Y - 1900
  500.                else
  501.                   Y := Y Mod 100;
  502.      end
  503.      else
  504.      begin
  505.          If Y < 1900 then
  506.             If Y < LastYearNextCentuary then
  507.                Y := Y + 2000
  508.             else
  509.                Y := Y + 1900;
  510.      end;
  511.      YY := Int_to_Str(Y);
  512.      If Y < 10 then
  513.         YY := '0'+YY;
  514.      Case Format of
  515.      MMDDYY,
  516.      MMDDYYYY: DMY_to_String := MM+PadChar+DD+Padchar+YY;
  517.      MMYY,
  518.      MMYYYY  : DMY_to_String := MM+Padchar+YY;
  519.      DDMMYY,
  520.      DDMMYYYY: DMY_to_String := DD+PadChar+MM+Padchar+YY;
  521.      end; {case}
  522.  end; {of func DMY_to_String}
  523.  
  524.  Function Date_To_Julian(InDate:string;format:byte): dates;
  525.  {Does not check the date is valid. Passed a date string and
  526.   returns a julian date}
  527.  var
  528.     D,M,Y :  word;
  529.     Temp : dates;
  530.  begin
  531.      D := Day(Indate,format);
  532.      M := Month(Indate,format);
  533.      Y := Year(Indate,format);
  534.      If  (Y=1900)
  535.      and (M <= 2) then
  536.      begin
  537.          If M = 1 then
  538.             Temp := pred(D)
  539.          else
  540.             Temp := D+30;
  541.      end
  542.      else
  543.      begin
  544.          If M > 2 then
  545.             M := M - 3
  546.          else
  547.          begin
  548.              M := M + 9;
  549.              dec(Y);
  550.          end;
  551.          Y := Y - 1900;
  552.          Temp := (1461*longint(Y) div 4) +
  553.                  (153*M+2) div 5 +
  554.                  D + 58;
  555.      end;
  556.      Date_to_Julian := Temp;
  557.  end; {of func Date_To_Julian}
  558.  
  559.  Function Julian_to_Date(J:dates;format:byte):string;
  560.  {}
  561.  var
  562.     D,M,Y : word;
  563.     Remainder,Factored : longint;
  564.  begin
  565.      If J = 0 then
  566.      begin
  567.          Case Format of
  568.          DDMMYY,MMDDYY :   Julian_to_date := '  /  /  ';
  569.          DDMMYYYY,MMDDYYYY:Julian_to_date := '  /  /    ';
  570.          MMYYYY:           Julian_to_Date := '  /    ';
  571.          else              Julian_to_date := '  /  ';
  572.          end;
  573.          exit;
  574.      end;
  575.      If J <= 58 then
  576.      begin
  577.          Y := 1900;
  578.          If J <= 30 then
  579.          begin
  580.              M := 1;
  581.              D := succ(J);
  582.          end
  583.          else
  584.          begin
  585.              M := 2;
  586.              D := J - 30;
  587.          end;
  588.      end
  589.      else
  590.      begin
  591.          Factored := 4*LongInt(J) - 233;
  592.          Y := Factored div 1461;
  593.          Remainder := (Factored mod 1461 div 4 * 5) + 2;
  594.          M := Remainder div 153;
  595.          D := succ((Remainder mod 153) div 5);
  596.          Y := Y + 1900;
  597.          If M < 10 then
  598.             M := M + 3
  599.          else
  600.          begin
  601.              M := M - 9;
  602.              Inc(Y);
  603.          end;
  604.      end;
  605.      Julian_to_date := DMY_to_String(D,M,Y,format);
  606.  end; {of proc Julian_to_Date}
  607.  
  608.  Function Date_Within_Range(Min,Max,Test:dates):boolean;
  609.  {}
  610.  begin
  611.      Date_Within_Range := ((Test >= Min) and (Test <= Max));
  612.  end; {of func Date_Within_Range}
  613.  
  614.  Function Valid_Date(Indate:string;format:byte): boolean;
  615.  {}
  616.  var
  617.    D,M,Y : word;
  618.    OK : Boolean;
  619.  begin
  620.      OK := true;  {positive thinking!}
  621.      If format in [MMYY,MMYYYY] then
  622.         D := 1
  623.      else
  624.         D := Day(Indate,format);
  625.      M := Month(Indate,format);
  626.      Y := Year(Indate,format);
  627.      If (D < 1)
  628.      or (D > 31)
  629.      or (M < 1)
  630.      or (M > 12)
  631.      or ((Y > 99) and (Y < 1900))
  632.      or (Y > 2078)
  633.      then 
  634.         OK := False
  635.      else
  636.         Case M of
  637.         4,6,9,11:         OK :=   (D <= 30);
  638.         2:                OK :=   (D <= 28)
  639.                                or (
  640.                                         (D = 29) 
  641.                                     and (Y <> 1900) 
  642.                                     and (Y <> 0)
  643.                                     and (Y mod 4 = 0)
  644.                                   )
  645.         end; {case}
  646.      Valid_Date := OK;
  647.  end; {of func Valid_Date}
  648.  
  649.  Function Today_in_Julian: dates;
  650.  {}
  651.  var
  652.  Y,
  653.  M,
  654.  D,
  655.  DayOfWeek : word;
  656.  Year   : string;
  657.  Day    : string;
  658.  begin
  659.      GetDate(Y,M,D,DayofWeek);
  660.      Today_in_Julian := Date_to_Julian(DMY_to_String(D,M,Y,1),1);
  661.  end; {of func Today_in_Julian}
  662.  
  663.  Function Future_Date(InDate:string;format:byte;Days:word): string;
  664.  {}
  665.  var J : dates;
  666.  begin
  667.      Future_date := Julian_to_date(Date_to_Julian(InDate,Format)+Days,Format);
  668.  end; {of func Future_Date}
  669.  
  670.  Function Unformatted_date(InDate:string): string;
  671.  {strips all non numeric characters}
  672.  var I : Integer;
  673.  
  674.            Function digit(C:char): boolean;
  675.            {}
  676.            begin
  677.                Digit := C in ['0'..'9'];
  678.            end; {of func digit}
  679.  
  680.  begin
  681.      I := 1;
  682.      Repeat
  683.           If (digit(Indate[I]) = false) and (length(Indate) > 0) then
  684.              Delete(Indate,I,1)
  685.           else
  686.              I := succ(I);
  687.      Until (I > length(Indate)) or (Indate = '');
  688.      Unformatted_Date := Indate;
  689.  end; {of func Unformatted_date}
  690.  
  691.  
  692. begin
  693.     ClockX := 67;
  694.     ClockY := 1;
  695.     ClockF := white;
  696.     ClockB := black;
  697.     LPTport := 0;  {LPT1}
  698. end.
  699.